home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 32 / cardgame.zip / KLONDIKE.BAS next >
BASIC Source File  |  1986-04-16  |  14KB  |  366 lines
  1. 10 CLS
  2. 15 DIM DECK$(52),PRE(52),SUIT$(4),CARD$(13),CLR(4,2),ROW$(7,19,2),NDECK$(52)
  3. 20 DIM ACES$(4)
  4. 25 DEF FNR(X)=INT((RND*X)+1)
  5. 26 RANDOMIZE(VAL(RIGHT$(TIME$,2)))
  6. 30 PRINT "Klondike Solitaire":PRINT
  7. 31 PRINT "Do you want color? ";
  8. 32 A$=INKEY$:IF A$="" THEN 32
  9. 33 GOSUB 10000:IF A$<>"Y" AND A$<>"N" THEN 32 ELSE PRINT A$:COL$=A$
  10. 34 PRINT "Do you need Instructions? ";
  11. 35 A$=INKEY$:IF A$="" THEN 35
  12. 36 GOSUB 10000:IF A$<>"Y" AND A$<>"N" THEN 35 ELSE PRINT A$
  13. 37 IF A$="Y" THEN GOSUB 5000
  14. 40 PRINT "Initializing ... "
  15. 45 GOSUB 1000
  16. 50 PRINT "Shuffling ... "
  17. 60 GOSUB 1200
  18. 65 PRINT "Dealing ... "
  19. 70 GOSUB 1500
  20. 80 GOSUB 1700
  21. 90 TOP=3
  22. 91 COLOR 7,1:LOCATE 15,50:PRINT " C - more cards              ";
  23. 92 LOCATE 16,50:PRINT " D - move from deck          ";
  24. 93 LOCATE 17,50:PRINT " Row Number to move from row ";
  25. 94 LOCATE 18,50:PRINT " Q to quit                   ";:COLOR 7,0
  26. 100 LOCATE 19,1:PRINT "Next card in deck:";
  27. 110 IF NDECK<1 THEN PRINT "None";:GOTO 140
  28. 120 C$=NDECK$(TOP):GOSUB 1300
  29. 140 LOCATE 21,1:PRINT USING "Card ## of ## left in deck";TOP;NDECK;
  30. 150 LOCATE 23,1:PRINT "                               ";
  31. 152 IF SCORE > 51 THEN 900
  32. 155 LOCATE 22,1:PRINT "What do you want to do?   ";:LOCATE 22,23
  33. 160 A$=INKEY$:IF A$="" THEN 160 ELSE GOSUB 10000
  34. 170 IF A$="C" THEN PRINT A$;:GOSUB 300:GOTO 100
  35. 180 IF A$="D" THEN PRINT A$;:GOSUB 350:GOTO 100
  36. 190 IF A$>="1" AND A$<="7" THEN PRINT A$;:GOSUB 600:GOTO 100
  37. 200 IF A$="Q" THEN 900
  38. 210 GOTO 160
  39. 300 REM Get more cards from deck
  40. 310 IF TOP=NDECK THEN TOP=3 ELSE TOP=TOP+3
  41. 320 IF TOP>NDECK THEN TOP=NDECK
  42. 330 RETURN
  43. 350 REM Move from deck to a row
  44. 360 LOCATE 23,1:PRINT "From deck to row? ";
  45. 380 A$=INKEY$:GOSUB 10000:IF (A$>="1" AND A$<="7") OR A$="A" THEN 390 ELSE 380
  46. 390 IF A$="A" THEN PRINT "Aces"; ELSE PRINT A$;
  47. 395 IF A$="A" THEN 540
  48. 400 TOROW=VAL(A$)
  49. 410 FOR PLACE=19 TO 1 STEP -1
  50. 420 IF ROW$(TOROW,PLACE,2)<>"   " THEN 460
  51. 430 NEXT PLACE
  52. 432 IF ROW$(TOROW,1,2)="   " AND LEFT$(NDECK$(TOP),2)=" K" THEN PLACE=0:GOTO 500
  53. 440 GOSUB 990
  54. 450 RETURN
  55. 460 BELOW$=ROW$(TOROW,PLACE,2)
  56. 470 ABOVE$=NDECK$(TOP)
  57. 480 GOSUB 2000       'check if match
  58. 490 IF OK$="NO" THEN 440
  59. 500 ROW$(TOROW,PLACE+1,1)=NDECK$(TOP)
  60. 510 ROW$(TOROW,PLACE+1,2)=NDECK$(TOP)
  61. 520 ROW=TOROW:GOSUB 3100
  62. 525 GOSUB 2200        'repack deck
  63. 530 RETURN
  64. 540 REM Play Deck to Aces
  65. 550 ABOVE$=NDECK$(TOP)
  66. 560 GOSUB 2300        'play to aces
  67. 570 IF OK$="NO" THEN 440
  68. 580 GOTO 525
  69. 600 REM Move from one row to another
  70. 610 FROMROW=VAL(A$)
  71. 620 FOR FROMPLACE=1 TO 19
  72. 630 IF ROW$(FROMROW,FROMPLACE,2)<>DOWN$ THEN 660
  73. 640 NEXT FROMPLACE
  74. 650 GOSUB 990:RETURN
  75. 660 LOCATE 23,1:PRINT "From row";FROMROW;"to row? ";
  76. 680 A$=INKEY$:GOSUB 10000:IF (A$>="1" AND A$<="7") OR A$="A" THEN 690 ELSE 680
  77. 690 IF A$="A" THEN PRINT "Aces"; ELSE PRINT A$;
  78. 695 IF A$="A" THEN 830
  79. 700 TOROW=VAL(A$)
  80. 710 FOR TOPLACE=19 TO 1 STEP -1
  81. 720 IF ROW$(TOROW,TOPLACE,2)<>"   " THEN 760
  82. 730 NEXT TOPLACE
  83. 732 IF ROW$(TOROW,1,2)="   " AND LEFT$(ROW$(FROMROW,FROMPLACE,2),2)=" K" THEN TOPLACE=0:GOTO 800
  84. 740 GOSUB 990
  85. 750 RETURN
  86. 760 REM
  87. 770 ABOVE$=ROW$(FROMROW,FROMPLACE,2)
  88. 775 BELOW$=ROW$(TOROW,TOPLACE,2)
  89. 780 GOSUB 2000               'check if match
  90. 790 IF OK$="NO" THEN 740
  91. 800 GOSUB 3200               'move the stack
  92. 810 ROW=FROMROW:GOSUB 3100   'redraw a row
  93. 815 ROW=TOROW:GOSUB 3100     'redraw a row
  94. 820 RETURN
  95. 830 REM play from a row to aces
  96. 832 FOR FROMPLACE=19 TO 1 STEP -1
  97. 834 IF ROW$(FROMROW,FROMPLACE,2)<>"   " THEN 840
  98. 836 NEXT FROMPLACE
  99. 838 GOSUB 990:RETURN
  100. 840 ABOVE$=ROW$(FROMROW,FROMPLACE,2)
  101. 850 GOSUB 2300        'play to aces
  102. 851 IF OK$="NO" THEN 740
  103. 853 REM ROW$(FROMROW,FROMPLACE,1)="   "
  104. 854 ROW$(FROMROW,FROMPLACE,2)="   "
  105. 855 IF FROMPLACE>1 THEN ROW$(FROMROW,FROMPLACE-1,2)=ROW$(FROMROW,FROMPLACE-1,1)
  106. 856 ROW=FROMROW:GOSUB 3100   'redraw a row
  107. 860 RETURN
  108. 900 REM Exit game
  109. 901 LOCATE 19,1:PRINT "                                ";
  110. 902 LOCATE 21,1:PRINT "                                ";
  111. 903 LOCATE 22,1:PRINT "                                ";
  112. 904 LOCATE 23,1:PRINT "                                ";
  113. 905 LOCATE 24,1:PRINT "                                ";
  114. 910 GOSUB 1800
  115. 920 GOSUB 1900
  116. 925 FOR I=1 TO 20:A$=INKEY$:NEXT I
  117. 930 GOSUB 3400:PRINT "Play again? (Y or N) ";
  118. 940 A$=INKEY$:IF A$="" THEN 940
  119. 950 GOSUB 10000
  120. 960 IF A$="N" THEN 970 
  121. 961 IF A$="Y" THEN CLS:PRINT "Re-";:GOTO 40
  122. 965 GO TO 940
  123. 970 CLS:PRINT "Bye":END
  124. 990 REM Bad Play
  125. 992 COLOR 0,7:LOCATE 23,50:PRINT " Can't do that!            ";
  126. 994 LOCATE 24,50:PRINT " Press any key to continue ";:COLOR 7,0
  127. 996 IF INKEY$="" THEN 996
  128. 997 LOCATE 23,50:PRINT "                            ";
  129. 998 LOCATE 24,50:PRINT "                            ";
  130. 999 RETURN
  131. 1000 REM
  132. 1005 DOWN$=CHR$(178):DOWN$=DOWN$+DOWN$+DOWN$
  133. 1009 IF COL$="N" THEN 1020
  134. 1010 FOR I=1 TO 2:CLR(I,1)=4:CLR(I,2)=7:NEXT
  135. 1015 FOR I=3 TO 4:CLR(I,1)=0:CLR(I,2)=7:NEXT
  136. 1019 GO TO 1030
  137. 1020 FOR I=1 TO 2:CLR(I,1)=0:CLR(I,2)=7:NEXT
  138. 1025 FOR I=3 TO 4:CLR(I,1)=7:CLR(I,2)=0:NEXT
  139. 1030 FOR I=1 TO 4:SUIT$(I)=CHR$(I+2):NEXT I
  140. 1035 FOR I=1 TO 4:ACES$(I)="   ":NEXT I
  141. 1040 FOR I=2 TO 9:CARD$(I)=STR$(I):NEXT I
  142. 1050 CARD$(1)=" A":CARD$(10)="10":CARD$(11)=" J":CARD$(12)=" Q":CARD$(13)=" K"
  143. 1060 FOR I=1 TO 4
  144. 1070 FOR J=1 TO 13
  145. 1080 K=(I-1)*13+J
  146. 1090 DECK$(K)=CARD$(J)+SUIT$(I)
  147. 1100 NEXT J
  148. 1110 NEXT I
  149. 1120 FOR I=1 TO 7
  150. 1130 FOR J=1 TO 19
  151. 1140 ROW$(I,J,1)="   ":ROW$(I,J,2)="   "
  152. 1150 NEXT J,I
  153. 1160 SCORE=0
  154. 1170 RETURN
  155. 1200 REM Shuffle
  156. 1210 FOR I=1 TO 52:NDECK$(I)="":NEXT I
  157. 1220 FOR I=1 TO 52
  158. 1230 R=FNR(52)
  159. 1240 IF NDECK$(R)="" THEN NDECK$(R)=DECK$(I) ELSE 1230
  160. 1250 NEXT I
  161. 1260 FOR I=1 TO 52
  162. 1270 DECK$(I)=NDECK$(I)
  163. 1280 NEXT I
  164. 1290 RETURN
  165. 1300 REM Display a card (C$)
  166. 1310 IF C$=DOWN$ THEN 1350
  167. 1320 IF C$="   " THEN 1350
  168. 1330 S=ASC(RIGHT$(C$,1))-2
  169. 1340 COLOR CLR(S,1),CLR(S,2)
  170. 1350 PRINT C$;:COLOR 7,0:PRINT "    ";
  171. 1360 RETURN
  172. 1500 REM Deal the game
  173. 1510 C=1
  174. 1520 FOR PLACE=1 TO 7
  175. 1530 FOR ROW=1 TO 7
  176. 1535 IF ROW<PLACE THEN ROW$(ROW,PLACE,1)="   ":ROW$(ROW,PLACE,2)="   ":GOTO 1570
  177. 1540 ROW$(ROW,PLACE,1)=DECK$(C)
  178. 1550 C=C+1
  179. 1560 IF ROW=PLACE THEN ROW$(ROW,PLACE,2)=ROW$(ROW,PLACE,1) ELSE ROW$(ROW,PLACE,2)=DOWN$
  180. 1570 NEXT ROW,PLACE
  181. 1580 CLS
  182. 1590 L=10:LOCATE 1,5:PRINT "Aces:"
  183. 1600 REM FOR ACE=1 TO 4
  184. 1610 REM LOCATE 1,L:COLOR 0,7:PRINT "  ";SUIT$(ACE);:COLOR 7,0
  185. 1620 REM L=L+10
  186. 1630 REM NEXT ACE
  187. 1640 LOCATE 4,1
  188. 1645 PRINT " 1      2      3      4      5      6      7"
  189. 1650 FOR PLACE=1 TO 7
  190. 1660 FOR ROW=1 TO 7
  191. 1661 C$=ROW$(ROW,PLACE,2)
  192. 1665 C$=ROW$(ROW,PLACE,2)
  193. 1670 GOSUB 1300
  194. 1680 NEXT ROW:PRINT:NEXT PLACE
  195. 1690 RETURN
  196. 1700 REM Prepare to play
  197. 1710 FOR I=1 TO 24
  198. 1715 J=I+28
  199. 1720 NDECK$(I)=DECK$(J)
  200. 1730 NEXT I
  201. 1740 FOR I=25 TO 52
  202. 1750 NDECK$(I)=""
  203. 1760 NEXT I
  204. 1770 NDECK=24
  205. 1780 RETURN
  206. 1800 REM Show Deck
  207. 1810 LL=3
  208. 1815 LOCATE 3,50:PRINT "Cards left in deck:";
  209. 1817 IF NDECK=0 THEN 1890
  210. 1820 FOR I=1 TO NDECK STEP 3
  211. 1830 LL=LL+1:LOCATE LL,50
  212. 1840 FOR J=0 TO 2
  213. 1845 IF I+J>NDECK THEN 1870
  214. 1850 C$=NDECK$(I+J)
  215. 1860 GOSUB 1300
  216. 1870 NEXT J:PRINT "     ";:NEXT I
  217. 1880 RETURN
  218. 1890 LOCATE 4,50:PRINT "None.                     ";
  219. 1895 FOR I=2 TO 3:LOCATE LL+I,50:PRINT "                          ";:NEXT
  220. 1899 RETURN
  221. 1900 REM show cards
  222. 1910 LL=4:COUNT=0
  223. 1920 FOR PLACE=1 TO 19
  224. 1925 LL=LL+1:LOCATE LL,1
  225. 1930 FOR ROW=1 TO 7
  226. 1935 C$=ROW$(ROW,PLACE,2)
  227. 1940 IF C$=DOWN$ THEN C$=ROW$(ROW,PLACE,1):COUNT=COUNT+1
  228. 1950 GOSUB 1300
  229. 1960 NEXT ROW
  230. 1965 IF COUNT=0 THEN PLACE=20
  231. 1970 LOCATE LL,1:COUNT=0
  232. 1980 NEXT PLACE
  233. 1990 RETURN
  234. 2000 REM Check if above$ can go on below$
  235. 2010 IN$=ABOVE$:GOSUB 3000:ANUM=NUM:ASUIT=SUIT
  236. 2020 IN$=BELOW$:GOSUB 3000:BNUM=NUM:BSUIT=SUIT
  237. 2030 OK$="YES"
  238. 2040 IF ANUM+1<>BNUM THEN OK$="NO"
  239. 2050 IF ASUIT<=2 AND BSUIT<=2 THEN OK$="NO"
  240. 2060 IF ASUIT>=3 AND BSUIT>=3 THEN OK$="NO"
  241. 2070 RETURN
  242. 2200 REM Repack Deck
  243. 2205 IF NDECK=1 THEN TOP=0:NDECK=0:RETURN
  244. 2210 FOR I=TOP+1 TO NDECK
  245. 2220 NDECK$(I-1)=NDECK$(I)
  246. 2230 NEXT I
  247. 2240 NDECK=NDECK-1
  248. 2250 TOP=TOP-1
  249. 2260 IF TOP<1 THEN TOP=3
  250. 2280 IF TOP>NDECK THEN TOP=NDECK
  251. 2290 RETURN
  252. 2300 REM Play ABOVE$ to aces
  253. 2310 IN$=ABOVE$:GOSUB 3000:ANUM=NUM:ASUIT=SUIT
  254. 2315 IN$=ACES$(ASUIT):IF IN$="   " THEN BNUM=0:GOTO 2330
  255. 2320 GOSUB 3000:BNUM=NUM
  256. 2330 IF ANUM=BNUM+1 THEN OK$="YES" ELSE OK$="NO":RETURN
  257. 2340 ACES$(ASUIT)=ABOVE$
  258. 2350 LOCATE 1,ASUIT*10:C$=ABOVE$
  259. 2360 GOSUB 1300
  260. 2365 SCORE=SCORE+1:LOCATE 1,50:PRINT "Score";SCORE
  261. 2370 RETURN
  262. 3000 REM change in$ to num and suit
  263. 3005 IF A$="   " THEN NUM=0:SUIT=0:RETURN
  264. 3010 A$=LEFT$(IN$,2)
  265. 3020 IF A$=" A" THEN A$=" 1"
  266. 3030 IF A$=" J" THEN A$="11"
  267. 3040 IF A$=" Q" THEN A$="12"
  268. 3050 IF A$=" K" THEN A$="13"
  269. 3060 NUM=VAL(A$)
  270. 3070 SUIT=ASC(RIGHT$(IN$,1))-2
  271. 3080 RETURN
  272. 3100 REM Redraw a row
  273. 3110 R=((ROW-1)*7)+1
  274. 3130 FOR PLACE=1 TO 19
  275. 3140 IF ROW$(ROW,PLACE,1)="   " THEN PLACE=20:GOTO 3180
  276. 3150 LOCATE 4+PLACE,R
  277. 3160 C$=ROW$(ROW,PLACE,2)
  278. 3170 GOSUB 1300
  279. 3180 NEXT PLACE
  280. 3190 RETURN
  281. 3200 REM Copy part of a row
  282. 3205 FP=FROMPLACE:TP=TOPLACE
  283. 3207 IF TP=1 AND LEFT$(ROW$(FROMROW,FROMPLACE,2),2)=" K" THEN 3220
  284. 3210 TP=TP+1
  285. 3220 ROW$(TOROW,TP,1)=ROW$(FROMROW,FP,1)
  286. 3225 ROW$(TOROW,TP,2)=ROW$(FROMROW,FP,2)
  287. 3230 REM ROW$(FROMROW,FP,1)="   "
  288. 3235 ROW$(FROMROW,FP,2)="   "
  289. 3240 FP=FP+1
  290. 3250 IF ROW$(FROMROW,FP,2)<>"   " THEN 3210
  291. 3260 IF FROMPLACE>1 THEN 3300
  292. 3270 ROW$(FROMROW,FP,1)="   "
  293. 3280 ROW$(FROMROW,1,2)="   "
  294. 3290 RETURN
  295. 3300 ROW$(FROMROW,FROMPLACE-1,2)=ROW$(FROMROW,FROMPLACE-1,1)
  296. 3310 RETURN
  297. 3400 REM Evaluate game performance
  298. 3405 LOCATE 19,1:PRINT "You placed";SCORE;"cards on the Aces piles"
  299. 3410 SC=INT(SCORE/10)+1
  300. 3415 IF SCORE=52 THEN SC=7
  301. 3420 IF SCORE=0 THEN GOSUB 3520:RETURN
  302. 3430 ON SC GOSUB 3450,3460, 3470, 3480, 3490, 3500, 3510
  303. 3440 RETURN  'score 0-9  10-19 20-29 30-39 40-49 50+
  304. 3450 PRINT "Too bad, better try again!":RETURN
  305. 3460 PRINT "Not too bad, still a lot of room for improvement":RETURN
  306. 3470 PRINT "Pretty good, keep trying.":RETURN
  307. 3480 PRINT "Good job.  Keep up the good work!":RETURN
  308. 3490 PRINT "Very good.  Now you have the idea!":RETURN
  309. 3500 PRINT "Almost got it.  Bad break!":RETURN
  310. 3510 PRINT "YOU DID IT!!  Congratulations!":RETURN
  311. 3520 PRINT "Oops!  You must have had a bad shuffle!":RETURN
  312. 5000 REM Instructions
  313. 5010 cls:PRINT "Klondike Solitaire"
  314. 5020 PRINT 
  315. 5030 PRINT "This program plays a solitaire game.  A deck of 52 cards is" 
  316. 5040 PRINT "used and 28 cards are dealt into 7 rows (piles).  The first" 
  317. 5050 PRINT "row at the left has one card, the second two, and so on, up" 
  318. 5060 PRINT "to seven in the last row.  The last card of each row is face" 
  319. 5070 PRINT "up and all the rest are face down.  On each row you may"
  320. 5080 PRINT "build in descending sequence: red on black, such as the ten"
  321. 5090 PRINT "of hearts on the jack of clubs or spades.":PRINT 
  322. 5100 PRINT "You can move the face up cards in a row as a unit.  The top"
  323. 5110 PRINT "card being moved must fit in sequence and color with the"
  324. 5120 PRINT "card being moved under in the other row.  When you uncover a"
  325. 5130 PRINT "face-down card on a row, it will be turned up.":PRINT 
  326. 5140 PRINT "You are always entitled to have 7 rows, and if one is"
  327. 5150 PRINT "entirely open you may put a king in the space.  Whenever you"
  328. 5160 PRINT "free an ace, move it too the ace foundations.  On the aces"
  329. 5170 PRINT "you may build up in suit and sequence and then to win the"
  330. 5180 PRINT "game, you have to build each suit up to a king.  A card must"
  331. 5190 PRINT "be the top card of a row to be played from, to the rows onto"
  332. 5200 PRINT "the ace foundations.  Once played on the ace foundations, a"
  333. 5210 PRINT "card can NOT be removed to help elsewhere."
  334. 5220 PRINT "     ** Press any key to continue **";
  335. 5230 IF INKEY$="" THEN 5230 ELSE CLS
  336. 5240 PRINT "The remaining 24 cards in the deck are used as the stock."
  337. 5250 PRINT "Every third card may be turned up and the deck may be gone"
  338. 5260 PRINT "through any number of times.  The top card is available for"
  339. 5270 PRINT "play to any row or the ace foundations.  When the top card"
  340. 5280 PRINT "is played, the next card will then be available.":PRINT 
  341. 5290 PRINT "You win if you can build all 4 ace foundations up to kings."
  342. 5300 PRINT "You lose when you can not make any further plays from the"
  343. 5310 PRINT "deck, or rows.":PRINT 
  344. 5320 PRINT "Plays are controlled by keyboard commands as follows:":PRINT 
  345. 5330 PRINT "D = Play top card of the Deck to aces (A) or row (#1-7)."
  346. 5340 PRINT "    Answer 'A' or row number 1-7 to next question to"
  347. 5350 PRINT "    indicate where the card is to be moved."
  348. 5360 PRINT "C = Get next Card in the deck and wait for next play command."
  349. 5370 PRINT "Q = Quit game and turn over all face-down cards."
  350. 5380 PRINT "#1-7 = Play cards from row# to Aces (A) or another row (#1-7)"
  351. 5390 PRINT 
  352. 5400 PRINT "An error message will be displayed if an invalid response is"
  353. 5410 PRINT "given to any question or any invalid plays attempted."
  354. 5420 PRINT:PRINT "     ** Press any key to continue **";
  355. 5430 IF INKEY$="" THEN 5430 ELSE CLS:RETURN
  356. 10000 REM Shift A$ to upper case
  357. 10020 L=LEN(A$)                          'get length of a$
  358. 10030 FOR I=1 TO L                       'look at each char 
  359. 10040 TEST=ASC(MID$(A$,I,1))             'get acsii value
  360. 10050 IF TEST<97 OR TEST>122 THEN 10080  'skip if not lower case
  361. 10060 TEST=TEST-32                       'bump down to upper case
  362. 10070 MID$(A$,I,1)=CHR$(TEST)            'insert upper case back 
  363. 10080 NEXT I                             'move on to next char
  364. 10090 RETURN
  365. 
  366.